home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Cream of the Crop 21
/
Cream of the Crop 21 (Terry Blount) (October 1996).iso
/
program
/
srcbkvt.zip
/
ASC.ZIP
/
20-20-4.ASC
next >
Wrap
Text File
|
1996-07-08
|
6KB
|
258 lines
_20/20_
by Al Williams
Listing One
{ Shared memory component -- Williams }
unit shdmem;
interface
uses Windows, Messages, Classes, Controls,SysUtils, DsgnIntf, Forms, Dialogs;
type
TShareMem=class(TComponent)
private
Ffilename : TFileName; { File name }
FDeleteFlag : Bool; { Delete on close? }
FFirstUser : Bool; { First user? }
FNewFile : Bool; { New file? }
fileh : THandle; { File handle }
fmap : THandle; { Handle to map }
addr : PChar; { Base address }
Fcount : Integer; { Number of strings }
FSize : Integer; { Size of each string }
Mutex : THandle; { Access Mutex }
FValid : Bool; { Good flag }
protected
{ no protected declarations }
public
constructor Create(obj : TComponent); override;
destructor Destroy; override;
procedure Loaded; override;
procedure UnLock;
procedure Clear;
function Rcl(n : integer;var s : String) : Bool;
function Sto(n : integer; s: String) : Bool;
function Lock(timeout : integer) : Bool;
Property FirstUser : Bool read FFirstUser;
Property NewFile: Bool read FNewFile;
Property FileHandle : THandle read fileh;
Property Valid : Bool read FValid;
published
property Count : Integer read FCount write FCount default 100;
property Size : Integer read FSize write FSize default 256;
property Filename : TFileName read FFilename write FFilename;
Property DeleteFlag : Bool read FDeleteFlag write FDeleteFlag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('Samples', [TShareMem]);
end;
constructor TShareMem.Create(obj : TComponent);
begin
inherited Create(obj);
{ Default setup }
FCount:=100;
FSize:=256;
Mutex:=0;
fileh:=-1;
FDeleteFlag:=False;
end;
destructor TShareMem.Destroy;
begin
{ Clear items }
if addr <> nil then
UnmapViewOfFile(addr);
if fmap <> 0 then
CloseHandle(fmap);
if fileh <> -1 then
CloseHandle(fileh);
if Mutex <> 0 then
CloseHandle(Mutex);
inherited Destroy;
end;
procedure TShareMem.Loaded;
var
delflag : Integer;
begin
inherited Loaded;
{ Only load if not designing }
if not (csDesigning in ComponentState) then
begin
{ Create OR open file mapping -- if map exists, this
just opens it }
FValid:=True; { Assume good things }
if (Fdeleteflag) then
delflag:=FILE_FLAG_DELETE_ON_CLOSE
else
delflag:=0;
if Ffilename <> '' then
fileh:=CreateFile(PChar(Ffilename),
GENERIC_READ or GENERIC_WRITE,0, nil,
OPEN_ALWAYS, FILE_ATTRIBUTE_NORMAL or delflag,0)
else
fileh:=THandle(-1);
if (fileh<>THandle(-1)) and
(GetLastError=Error_Already_Exists) then
FNewFile:=False
else
FNewFile:=True;
fmap:=CreateFileMapping(fileh,nil,PAGE_READWRITE,0,
FCount*FSize,PChar(Name));
if GetLastError=Error_Already_Exists then
FFirstUser:=False
else
FFirstUser:=True;
if fileh=THandle(-1) then
FNewFile:=FFirstUser;
if (fmap=THandle(0)) then FValid:=False;
addr:=MapViewOfFile(fmap,FILE_MAP_ALL_ACCESS,0,0,
FCount*FSize);
{ Create locking mutex }
Mutex:=CreateMutex(nil,FALSE,PChar(Name+'X'));
if Mutex=THandle(0) then FValid:=False;
end;
end;
function TShareMem.Rcl(n : integer;var s : String) : Bool;
var
ps:PChar;
begin
{ Lock, retrieve, and unlock }
Lock(INFINITE);
ps:=PChar(addr+(n*FSize));
s:=StrPas(ps);
Unlock;
result:=True;
end;
function TShareMem.Sto(n : integer; s: String) : Bool;
var
p: PChar;
begin
{ Lock, store, and unlock }
Lock(INFINITE);
p:=PChar(addr+(n*FSize));
StrPCopy(p,s);
Unlock;
result:=True;
end;
function TShareMem.Lock(timeout : integer) : Bool;
begin
result:=WaitForSingleObject(Mutex,timeout)<>0;
end;
procedure TShareMem.Unlock;
begin
ReleaseMutex(Mutex);
end;
procedure TShareMem.Clear;
begin
Lock(INFINITE);
FillChar(addr^,FCount*FSize,0);
Unlock;
end;
end.
Listing Two
{ Check in form }
unit vckinfrm;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls,
Forms, Dialogs, StdCtrls, shdmem;
type
TForm1 = class(TForm)
Label1: TLabel;
Name: TEdit;
Label2: TLabel;
Company: TEdit;
Label3: TLabel;
Visited: TEdit;
Label4: TLabel;
Timefield: TEdit;
Label5: TLabel;
Key: TEdit;
CheckIn: TButton;
Clear: TButton;
SharedMemory: TShareMem; { Shared Memory!}
procedure ClearClick(Sender: TObject);
procedure CheckInClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
private
function GetNewKey : String;
{ Private declarations }
public
{ Public declarations }
end;
var
Form1: TForm1;
implementation
{$R *.DFM}
function TForm1.GetNewKey : String;
var
k : String;
keynum : Integer;
code : Integer;
begin
{ Lock shared memory }
SharedMemory.Lock(INFINITE);
{ Get next key }
SharedMemory.Rcl(0,k);
{ Convert to number }
Val(k,keynum,code);
{ Set return value from number (if string is empty
this ensures a zero return value) }
result:=IntToStr(keynum);
{ Increment next key value and put back }
keynum:=keynum+1;
k:=IntToStr(keynum);
SharedMemory.Sto(0,k);
SharedMemory.Unlock;
end;
procedure TForm1.CheckInClick(Sender: TObject);
begin
timefield.Text:=TimeToStr(Time);
key.Text:=GetNewKey;
{ commit to database here }
end;
procedure TForm1.ClearClick(Sender: TObject);
begin
timefield.Text:='';
key.Text:='';
name.Text:='';
company.Text:='';
visited.Text:='';
ActiveControl:=Name;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
if SharedMemory.NewFile then
{ clear memory }
SharedMemory.Clear;
end;
end.